home *** CD-ROM | disk | FTP | other *** search
/ Dictionaries & Language / Dictionaries and Language (Chestnut CD-ROM) (1993).iso / misc / vb30 / vb-blk3.inc < prev    next >
Encoding:
Text File  |  1986-02-07  |  22.3 KB  |  600 lines
  1.  
  2. {************************************************************************}
  3. {*                                                                      *}
  4. {*                     VB Main Procedures -- Block 3                    *}
  5. {*                                                                      *}
  6. {*        AddWordList        DeleteWordList         EditWordList        *}
  7. {*        MakeWordList       PrintWordList          RenameWordList      *}
  8. {*        StudyWordList      TestWordList                               *}
  9. {*                                                                      *}
  10. {************************************************************************}
  11.  
  12.  
  13.   overlay procedure AddWordList;
  14.   { add words to an existing list }
  15.     var
  16.       AddListName     : ListName;
  17.       AddArray        : WordList;
  18.       NumberOfPairs   : integer;
  19.       i               : integer;
  20.     begin
  21.       PrintPageHeader('Add To a List');
  22.       writeln;
  23.       AskDir;
  24.       writeln;
  25.       GetListName (AddListName,'enlarge',1);
  26.       if length(AddListName) > 0
  27.         then
  28.           begin
  29.             ReadList(NumberOfPairs,AddArray,AddListName);
  30.             if NumberOfPairs > 0
  31.               then
  32.                 begin
  33.                   if NumberOfPairs < 25
  34.                     then
  35.                       begin
  36.                         repeat
  37.                           writeln;
  38.                           spaces(5);
  39.                           i := succ(NumberOfPairs);
  40.                           write (i:2,'.  Enter an English word: ');
  41.                           readln (AddArray[i].EnglishWord);
  42.                           if length(AddArray[i].EnglishWord) > 0
  43.                             then
  44.                               begin
  45.                                 NumberOfPairs := succ(NumberOfPairs);
  46.                                 repeat
  47.                                   spaces(10);
  48.                                   write ('And the ',Language,' translation: ');
  49.                                   readln (AddArray[i].ForeignWord);
  50.                                   if length(AddArray[i].ForeignWord) = 0
  51.                                     then
  52.                                       Beep
  53.                                 until length(AddArray[i].ForeignWord) > 0;
  54.                                 writeln
  55.                               end;
  56.                           if NumberOfPairs in [4,8,12,16,20,24]
  57.                             then
  58.                               PrintPageHeader('Add To a List')
  59.                         until (length(AddArray[i].EnglishWord) = 0) or (NumberOfPairs = 25);
  60.                         writeln;
  61.                         WriteList (NumberOfPairs,AddArray,AddListName)
  62.                       end
  63.                     else
  64.                       begin
  65.                         spaces(12);
  66.                         writeln ('That list is full.');
  67.                         pause
  68.                       end
  69.                 end
  70.               else
  71.                 pause
  72.           end
  73.     end;
  74.  
  75.  
  76.   overlay procedure DeleteWordList;
  77.   { delete a word list }
  78.     var
  79.       More                : boolean;
  80.       DelListName         : ListName;
  81.       DelFileName         : FileName;
  82.       DelFile             : ListFile;
  83.       i                   : integer;
  84.     begin
  85.       More := TRUE;
  86.       while More do
  87.         begin
  88.           PrintPageHeader('Delete a List');
  89.           writeln;
  90.           AskDir;
  91.           writeln;
  92.           GetListName (DelListName,'delete',1);
  93.           if length(DelListName) > 0
  94.             then
  95.               begin
  96.                 writeln;
  97.                 if ask ('Delete ' + DelListName)
  98.                   then
  99.                     begin
  100.                       writeln;
  101.                       for i := 1 to length (DelListName) do
  102.                         DelListName[i] := UpCase(DelListName[i]);
  103.                       DelFileName := DelListName + '.' + Extent;
  104.                       assign (DelFile,DelFileName);
  105.                       {$I-} erase (DelFile) {$I+};
  106.                       if IOresult = 0
  107.                         then
  108.                           begin
  109.                             writeln;
  110.                             More := ask('Would you like to delete any other lists')
  111.                           end
  112.                         else
  113.                           begin
  114.                             writeln;
  115.                             More := ask('I couldn''t find that list.  Do you want to try again')
  116.                           end
  117.                     end
  118.                   else
  119.                     begin
  120.                       writeln;
  121.                       More := ask('Would you like to delete any other lists')
  122.                     end
  123.               end
  124.             else
  125.               More := FALSE
  126.         end
  127.     end;
  128.  
  129.  
  130.   overlay procedure EditWordList;
  131.   { edit an existing list }
  132.     var
  133.       EditListName     : ListName;
  134.       EditArray        : WordList;
  135.       NumberOfPairs    : integer;
  136.       TempWord         : FullWord;
  137.       i,j              : integer;
  138.       More             : boolean;
  139.     begin
  140.       More := TRUE;
  141.       while More do
  142.         begin
  143.           PrintPageHeader('Edit a List');
  144.           writeln;
  145.           AskDir;
  146.           writeln;
  147.           GetListName (EditListName,'edit',1);
  148.           if length(EditListName) > 0
  149.             then
  150.               begin
  151.                 ReadList (NumberOfPairs,EditArray,EditListName);
  152.                 if NumberOfPairs > 0
  153.                   then
  154.                     begin
  155.                       writeln;
  156.                       SetPage('Edit a List',14,'Current Word',18,
  157.                               'Replacement (CR to leave as is)');
  158.                       writeln;
  159.                       writeln;
  160.                       for i := 1 to NumberOfPairs do
  161.                         begin
  162.                           j := (40 - length (EditArray[i].EnglishWord)) div 2;
  163.                           spaces (j);
  164.                           write (EditArray[i].EnglishWord);
  165.                           spaces (j + 5);
  166.                           readln (TempWord);
  167.                           if length (TempWord) > 0
  168.                             then
  169.                               EditArray[i].EnglishWord := copy(TempWord,1,length(TempWord));
  170.                           j := (40 - length (EditArray[i].ForeignWord)) div 2;
  171.                           spaces (j);
  172.                           write (EditArray[i].ForeignWord);
  173.                           spaces (j + 5);
  174.                           readln (TempWord);
  175.                           if length (TempWord) > 0
  176.                             then
  177.                               EditArray[i].ForeignWord := copy(TempWord,1,length(TempWord));
  178.                           writeln;
  179.                           if i in [4,8,12,16,20,24]
  180.                             then
  181.                               begin
  182.                                 writeln;
  183.                                 SetPage('Edit a List',14,'Current Word',18,
  184.                                         'Replacement (CR to leave as is)');
  185.                                 writeln;
  186.                                 writeln
  187.                               end
  188.                         end;
  189.                         writeln;
  190.                         WriteList (NumberOfPairs,EditArray,EditListName)
  191.                     end
  192.               end
  193.             else
  194.               More := FALSE;
  195.           writeln;
  196.           if More then
  197.               More := ask ('Would you like to edit another list')
  198.         end
  199.     end;
  200.  
  201.  
  202.   overlay procedure MakeWordList;
  203.   { construct a word list file }
  204.     var
  205.       NumberOfPairs      : integer;
  206.       i                  : integer;
  207.       Name               : ListName;
  208.       Pair               : WordPair;
  209.       FileID             : ListFile;
  210.       NameOfFile         : FileName;
  211.     begin
  212.       PrintPageHeader('Make a Word List');
  213.       writeln;
  214.       GetListName(Name,'What would you like to call this list',2);
  215.       if length(Name) > 0
  216.         then
  217.           begin
  218.             writeln;
  219.             NumberOfPairs := 0;
  220.             for i := 1 to length(Name) do
  221.               Name[i] := UpCase(Name[i]);
  222.             NameOfFile := Name + '.' + Extent;
  223.             if not (ExistFile(FileID,NameOfFile))
  224.               then
  225.                 begin
  226.                   {$I-} rewrite (FileID) {$I+};
  227.                   if IOresult = 0
  228.                     then
  229.                       begin
  230.                         repeat
  231.                           spaces(5);
  232.                           i := succ(NumberOfPairs);
  233.                           write (i:2,'.  ');
  234.                           write ('Enter an English word: ');
  235.                           readln (Pair.EnglishWord);
  236.                           if length(Pair.EnglishWord) > 0
  237.                             then
  238.                               begin
  239.                                 NumberOfPairs := succ(NumberOfPairs);
  240.                                 repeat
  241.                                   spaces(10);
  242.                                   write ('And the ',Language,' translation: ');
  243.                                   readln (Pair.ForeignWord);
  244.                                   if length(Pair.ForeignWord) = 0
  245.                                     then
  246.                                       Beep
  247.                                 until length(Pair.ForeignWord) > 0;
  248.                                 writeln;
  249.                                 write (FileID,Pair)
  250.                               end;
  251.                           if NumberOfPairs in [4,8,12,16,20,24]
  252.                             then
  253.                               begin
  254.                                 PrintPageHeader('Make a Word List');
  255.                                 writeln
  256.                               end
  257.                         until (length(Pair.EnglishWord) = 0) or (NumberOfPairs = 25);
  258.                         close (FileID);
  259.                         writeln;
  260.                         spaces (10);
  261.                         writeln ('Word list ',Name,', with ',NumberOfPairs,
  262.                                  ' pairs of words, has been created.');
  263.                         pause
  264.                       end
  265.                     else
  266.                       begin
  267.                         writeln;
  268.                         spaces(10);
  269.                         center ('There are too many directory entries to open ' +
  270.                                  NameOfFile,TRUE);
  271.                         pause
  272.                       end
  273.                 end
  274.               else
  275.                 begin
  276.                   writeln;
  277.                   spaces(12);
  278.                   writeln('The list ',Name,' already exists.');
  279.                   pause
  280.                 end
  281.           end
  282.     end;
  283.  
  284.  
  285.   overlay procedure PrintWordList;
  286.   { print a word list }
  287.     var
  288.       More            : boolean;
  289.       PrintListName   : ListName;
  290.       PrintArray      : WordList;
  291.       i               : integer;
  292.       NumberOfPairs   : integer;
  293.       LengthE         : integer;
  294.       LengthF         : integer;
  295.       LengthL         : integer;
  296.       Indent          : integer;
  297.     begin
  298.       More := TRUE;
  299.       while More do
  300.         begin
  301.           PrintPageHeader('Print a List');
  302.           writeln;
  303.           AskDir;
  304.           writeln;
  305.           GetListName (PrintListName,'print',1);
  306.           if length(PrintListName) > 0
  307.             then
  308.               begin
  309.                 ReadList(NumberOfPairs,PrintArray,PrintListName);
  310.                 if NumberOfPairs > 0
  311.                   then
  312.                     begin
  313.                       LengthE := 0;  LengthF := 0;
  314.                       for i := 1 to NumberOfPairs do
  315.                         begin
  316.                           if length(PrintArray[i].EnglishWord) > LengthE
  317.                             then LengthE := length(PrintArray[i].EnglishWord);
  318.                           if length(PrintArray[i].ForeignWord) > LengthF
  319.                             then LengthF := length(PrintArray[i].ForeignWord);
  320.                         end;
  321.                       LengthL := LengthE + LengthF + 5;
  322.                       Indent := (LengthL - length(PrintListName)) div 2;
  323.                       writeln (LST);
  324.                       writeln (LST); write (LST,'          ');
  325.                       for i := 1 to Indent do write (LST,' ');
  326.                       writeln (LST,PrintListName);
  327.                       writeln (LST);
  328.                       for i := 1 to NumberOfPairs do
  329.                         begin
  330.                           write (LST,'          ');
  331.                           writeln (LST,pad(PrintArray[i].EnglishWord,LengthE),
  332.                                        PrintArray[i].ForeignWord)
  333.                         end;
  334.                       write (LST,chr(FF))
  335.                     end;
  336.                 writeln;
  337.                 more := ask('Would you like to print another list')
  338.               end
  339.             else
  340.               More := FALSE
  341.         end
  342.     end;
  343.  
  344.  
  345.   overlay procedure RenameWordList;
  346.   { rename word lists }
  347.     var
  348.       NewFile         : ListFIle;
  349.       OldFileName,
  350.       NewFileName     : FileName;
  351.       OldListName,
  352.       NewListName     : ListName;
  353.       More            : boolean;
  354.       i               : integer;
  355.     begin
  356.       More := TRUE;
  357.       while More do
  358.         begin
  359.           PrintPageHeader('Rename a List');
  360.           writeln;
  361.           AskDir;
  362.           writeln;
  363.           GetListName(OldListName,'rename',1);
  364.           if length (OldListName) > 0
  365.             then
  366.               begin
  367.                 writeln;
  368.                 repeat
  369.                   GetListName(NewListName,'What would you like to call it',2);
  370.                   if length(NewListName) = 0
  371.                     then
  372.                       Beep
  373.                 until length(NewListName) > 0;
  374.                 writeln;
  375.                 if ask('Rename ' + OldListName + ' to ' + NewListName)
  376.                   then
  377.                     begin
  378.                       writeln;
  379.                       for i := 1 to length (OldListName) do
  380.                         OldListName[i] := UpCase(OldListName[i]);
  381.                       for i := 1 to length (NewListName) do
  382.                         NewListName[i] := UpCase(NewListName[i]);
  383.                       writeln;
  384.                       OldFileName := OldListName + '.' + Extent;
  385.                       NewFileName := NewListName + '.' + Extent;
  386.                       assign (NewFile,OldFileName);
  387.                       {$I-} rename(NewFile,NewFileName) {$I+};
  388.                       if IOresult = 0
  389.                         then
  390.                           more := ask('Would you like to rename other lists')
  391.                         else
  392.                           more := ask('I couldn''t find that list.  Do you want to try again');
  393.                       close (NewFile)
  394.                     end
  395.                 else
  396.                   begin
  397.                     writeln;
  398.                     writeln;
  399.                     More := ask('Would you like to rename other lists')
  400.                   end
  401.               end
  402.             else
  403.               More := FALSE
  404.         end
  405.     end;
  406.  
  407.  
  408.   overlay procedure StudyWordList;
  409.   { study a word list }
  410.     var
  411.       StudyListName      : ListName;
  412.       NumberOfPairs      : integer;
  413.       NumberCorrect      : integer;
  414.       StudyArray         : WordList;
  415.       Order              : Ordering;
  416.       EnglishFirst       : boolean;
  417.       TempWord           : FullWord;
  418.       WordA, WordB       : FullWord;
  419.       i, j               : integer;
  420.  
  421.     procedure WordOkay;
  422.     { if they got it right }
  423.       const
  424.         OKMessage : array[1..23] of FullWord =
  425.          ( 'Correct!'          ,  'That''s right!'    ,  'Fantastic!'    ,  'Super!'           ,
  426.            'You''re a champ!'  ,  'Pure genius!'      ,  'Brilliant!'    ,  'All right!'       ,
  427.            'Wowee!'            ,  'That''s the way!'  ,  'Right again!'  ,  'Wonderful!'       ,
  428.            'Not bad!'          ,  'Yes!'              ,  'That''s it!'   ,  'Exactly right!'   ,
  429.            'Flawless!'         ,  'Precisely!'        ,  'Absolutely!'   ,  'I''m impressed!'  ,
  430.            'Awesome!'          ,  'Fabulous!'         ,  'What a touch!'  );
  431.       var
  432.         i : integer;
  433.       begin
  434.         randomize;
  435.         i := random(23) + 1;
  436.         writeln;
  437.         center(OKMessage[i],TRUE);
  438.         delay(Time)
  439.       end;
  440.  
  441.     procedure WordWrong(Word : FullWord);
  442.     { if they got it wrong }
  443.       const
  444.         NotOKMessage : array [1..14] of FullWord =
  445.          ( 'You''ll have to work on that one.'  ,  'Close, but not quite.'  ,
  446.            'Oops.'                              ,  'No, sorry.'             ,
  447.            'Hmmm.  Not quite.'                  ,  'I''m afraid not.'       ,
  448.            'Nope.  That''s not it.'             ,  'Almost.'                ,
  449.            'You missed that one.'               ,  'Darn it.'               ,
  450.            'Not quite.'                         ,  'Shucks.'                ,
  451.            'Whoops.'                            ,  'Sorry about that.'      );
  452.       var
  453.         TempW : FullWord;
  454.         i     : integer;
  455.       begin
  456.         repeat
  457.           randomize;
  458.           i := random(14) + 1;
  459.           writeln;
  460.           center(NotOKMessage[i],TRUE);
  461.           writeln;
  462.           writeln;
  463.           delay(Time);
  464.           spaces(10);
  465.           writeln ('The correct translation is: ',Word);
  466.           spaces(10);
  467.           write   ('Please type it in now:      ');
  468.           readln (TempW)
  469.         until (TempW = Word)
  470.       end;
  471.  
  472.     begin  { StudyWordList }
  473.       PrintPageHeader('Study a List');
  474.       writeln;
  475.       AskDir;
  476.       writeln;
  477.       GetListName (StudyListName,'study',1);
  478.       if length (StudyListName) > 0
  479.         then
  480.           begin
  481.             ReadList(NumberOfPairs,StudyArray,StudyListName);
  482.             if NumberOfPairs > 0
  483.               then
  484.                 begin
  485.                   SetRandomOrder(Order,NumberOfPairs);
  486.                   EnglishFirst := SetSequence(FALSE);
  487.                   NumberCorrect := 0;
  488.                   for i := 1 to NumberOfPairs do
  489.                     begin
  490.                       SetPage('Study a List',10,' ',33,'Translation');
  491.                       writeln;
  492.                       writeln;
  493.                       if EnglishFirst
  494.                         then
  495.                           begin
  496.                             WordA :=  StudyArray[Order[i]].EnglishWord;
  497.                             WordB :=  StudyArray[Order[i]].ForeignWord
  498.                           end
  499.                         else
  500.                           begin
  501.                             WordA :=  StudyArray[Order[i]].ForeignWord;
  502.                             WordB :=  StudyArray[Order[i]].EnglishWord
  503.                           end;
  504.                       j := (40 - length(WordA)) div 2;
  505.                       spaces (j);
  506.                       write (WordA);
  507.                       spaces(j + 6);
  508.                       readln (TempWord);
  509.                       if TempWord = WordB
  510.                         then
  511.                           begin
  512.                             WordOkay;
  513.                             NumberCorrect := succ(NumberCorrect)
  514.                           end
  515.                         else
  516.                           WordWrong(WordB)
  517.                     end;
  518.                   StudyReport(NumberOfPairs,NumberCorrect,FALSE,StudyArray,
  519.                               StudyListName,Order)
  520.                 end
  521.           end
  522.     end;
  523.  
  524.  
  525.   overlay procedure TestWordList;
  526.   { test for mastery of a list }
  527.     var
  528.       TestListName       : ListName;
  529.       NumberOfPairs      : integer;
  530.       NumberCorrect      : integer;
  531.       TestArray          : WordList;
  532.       Order              : Ordering;
  533.       EnglishFirst       : boolean;
  534.       TempWord           : FullWord;
  535.       WordA, WordB       : FullWord;
  536.       i, j               : integer;
  537.       MissFlag           : Ordering;
  538.       Rand               : boolean;
  539.     begin
  540.       Rand := FALSE;
  541.       PrintPageHeader('Testing For Mastery');
  542.       writeln;
  543.       AskDir;
  544.       writeln;
  545.       GetListName (TestListName,'try',1);
  546.       if length (TestListName) > 0
  547.         then
  548.           begin
  549.             ReadList(NumberOfPairs,TestArray,TestListName);
  550.             if NumberOfPairs > 0
  551.               then
  552.                 begin
  553.                   SetRandomOrder(Order,NumberOfPairs);
  554.                   EnglishFirst := SetSequence(TRUE);
  555.                   if Response in ['R','r']
  556.                     then
  557.                       Rand := TRUE;
  558.                   NumberCorrect := 0;
  559.                   for i := 1 to NumberOfPairs do
  560.                     begin
  561.                       MissFlag[Order[i]] := 0;
  562.                       if Rand
  563.                         then
  564.                           begin
  565.                             randomize;
  566.                             EnglishFirst := ((random(2) + 1) = 1)
  567.                           end;
  568.                       SetPage('Testing For Mastery',10,' ',33,'Translation');
  569.                       writeln;
  570.                       writeln;
  571.                       if EnglishFirst
  572.                         then
  573.                           begin
  574.                             WordA :=  TestArray[Order[i]].EnglishWord;
  575.                             WordB :=  TestArray[Order[i]].ForeignWord
  576.                           end
  577.                         else
  578.                           begin
  579.                             WordA :=  TestArray[Order[i]].ForeignWord;
  580.                             WordB :=  TestArray[Order[i]].EnglishWord
  581.                           end;
  582.                       j := (40 - length(WordA)) div 2;
  583.                       spaces (j);
  584.                       write (WordA);
  585.                       spaces(j + 6);
  586.                       readln (TempWord);
  587.                       if TempWord = WordB
  588.                         then
  589.                           NumberCorrect := succ(NumberCorrect)
  590.                         else
  591.                           MissFlag[Order[i]] := 1
  592.                     end;
  593.                   StudyReport(NumberOfPairs,NumberCorrect,TRUE,TestArray,
  594.                               TestListName,MissFlag)
  595.                 end
  596.           end
  597.     end;
  598.  
  599.  
  600.